home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / gera.arj / GERA.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-12-27  |  4.5 KB  |  195 lines
  1. uses crt,dos;
  2.  
  3.  
  4. { GERA.PAS  - Global search utility to find and delete files.      }
  5. {- drive not specified - uses the current                          }
  6. {- always starts at the root directory and searches every          }
  7. {  directory below it.                                             }
  8. { C.V. Rutherford }
  9. { Public domain 12/28/93 }
  10.  
  11.  
  12.  
  13. type
  14.   PathRecPTR = ^PathRecord;
  15.   PathRecord = record
  16.                  RDir: PathStr;
  17.                  Next: PathRecPTR;
  18.                end;
  19.  
  20. var
  21.   CurTop,
  22.   TempPTR: PathRecPTR;         { Pointer to path references }
  23.   FilesFound : Boolean;        { end of utility display     }
  24.  
  25. procedure CheckAborted( ch : char );
  26. begin
  27.   if ch in [#27,^C] then
  28.      begin
  29.        writeln(#08,'... User abort !');
  30.        HALT(0);
  31.      end;
  32. end;
  33.  
  34. { PushDir/PopDir/ClearDir }
  35. { are used to save and restore directories during search }
  36.  
  37. procedure PushDir( Rdir : PathStr );
  38. begin
  39.   New( TempPTR );
  40.   TempPTR^.RDir:= RDir;
  41.   TempPTR^.Next:= NIL;
  42.   if CurTop = Nil then
  43.      CurTop := TempPTR
  44.   else
  45.      begin
  46.        TempPTR^.Next := CurTop;
  47.        CurTop := TempPTR;
  48.      end;
  49. end;
  50.  
  51.  
  52. procedure PopDir(Var RDir : string );
  53. begin
  54.   if CurTop <> NIL then
  55.      begin
  56.        TempPTR := CurTop;
  57.        CurTop := CurTop^.Next;
  58.        RDir := TempPTR^.RDir;
  59.        Dispose( TempPTR );
  60.        TempPTR := NIL;
  61.      end;
  62. end;
  63.  
  64.  
  65. procedure ClearDir;
  66. begin
  67.   while CurTop <> NIL do
  68.     begin
  69.       TempPTR := CurTop;
  70.       CurTop := CurTop^.Next;
  71.       FreeMem( TempPTR, sizeof(PathRecord ));
  72.       TempPTR := NIL;
  73.    end;
  74. end;
  75.  
  76.  
  77. procedure GetDir( PathN : string );
  78. var
  79.   f : searchrec;
  80.  
  81. begin
  82.   findfirst(PathN+'*.*', directory,f);
  83.   while doserror = 0 do
  84.     begin
  85.       if (f.attr and directory) = directory then
  86.          begin
  87.            if (f.name <> '.') and (f.name <> '..') then
  88.               pushdir( PathN +f.name+'\');
  89.          end;
  90.       findnext(f);
  91.      end;
  92. end;
  93.  
  94.  
  95. procedure EraseFile( Source : string );
  96. var
  97.  F:  file;
  98.  ErrorCode : word;
  99.  ch : char;
  100.  
  101. begin
  102.   write('Delete: ', Source+' [N]',#08+#08 );
  103.   ch := Upcase( Readkey );
  104.   if ch = 'Y' then
  105.      begin
  106.        write('Y');
  107.        Assign(F, Source);
  108.        {$I-} Reset(F); {$I+}
  109.        ErrorCode := IOResult;
  110.        if errorCode = 0 then
  111.           begin
  112.             Close(F);
  113.             {$I-} Erase(F); {$I+}
  114.             ErrorCode := IOResult
  115.           end;
  116.        if ErrorCode <> 0 then
  117.           write(']    ', '... File Access denied');
  118.      end
  119.   else
  120.      CheckAborted( ch );
  121.   writeln;
  122. end;
  123.  
  124.  
  125. procedure GetFiles( PathN, FName : string );
  126. var
  127.   f : searchrec;
  128.  
  129. begin
  130.   findfirst(PathN+FName, anyfile,f);
  131.  
  132.   while keypressed do CheckAborted( Readkey );   { check for user abort }
  133.  
  134.   { 18 the only error we should get since we read the directory once before }
  135.   { indicating no more file found }
  136.  
  137.   while doserror <> 18 do
  138.     begin
  139.       if (F.attr and directory) <> Directory then
  140.          begin
  141.            erasefile(PathN+f.name);        (* ERASE REFERENCE *)
  142. (*         writeln(PathN+F.Name);           FIND REFERENCE  *)
  143.            FilesFound := TRUE;
  144.          end;
  145.       findnext(f);
  146.      end;
  147. end;
  148.  
  149.  
  150. procedure GlobalErase(Pname, mask : string );
  151. begin
  152.   pushdir(Pname);                { Push the root directory }
  153.   while curtop <> NIL do
  154.     begin
  155.       popdir( pname );           { get directory from list }
  156.       getdir( pname );           { get its subdirectories  }
  157.       write('*',#13);            {* provide an indicator   }
  158.       getfiles(pname, mask);     { get directory files     }
  159.       write('-',#13);            {* provide an indicator   }
  160.     end;
  161.   write(' ',#13);                {* clear the indicator    }
  162. end;
  163.  
  164. var
  165.  Dir: DirStr;
  166.  Name: NameStr;
  167.  Ext: ExtStr;
  168.  
  169. begin
  170.   CheckBreak := FALSE;           { use our abort }
  171.   FilesFound := FALSE;
  172.   if paramcount > 0 then
  173.      begin
  174.        FSplit(Paramstr(1), Dir, Name, Ext);
  175.        Dir := fexpand(Dir);               { Expand to get drive if not }
  176.                                           { specified }
  177.        Dir := Copy(Dir,1,1)+':\';         { Get drive or default drive }
  178.  
  179.        writeln;
  180.        writeln('Global Erase..  '+Dir+name+Ext);
  181.  
  182.        if ( Name='') or (Ext='') or (Ext='.') then
  183.           writeln('Invalid filename.. ?' )
  184.        else
  185.           begin
  186.             GlobalErase( Dir, Name+Ext );
  187.             if not FilesFound then
  188.                writeln(Name+Ext+' not found ?');
  189.           end;
  190.      end
  191.   else
  192.      writeln('Filename Not Specified.. ?');
  193.   cleardir;
  194. end.
  195.